Monster Media 1996 #15/Monster Media Number 15 (Monster Media)(July 1996).ISO/netmail/rnr214.zip/LINEDRAW.PAS

Pascal/Delphi Source File | 1996-02-02 | 5KB | 263 lines

unit linedraw;

{
[e-mail] (960202)

Copyright 1996 Russell Schulz

this code is not in the Public Domain

permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason.  have fun.
}

interface

uses dos,crt;

const
  maxsavedbytes=4096;

  singletlchar=#218;
  singletrchar=#191;
  singleblchar=#192;
  singlebrchar=#217;
  singlehlinechar=#196;
  singlevlinechar=#179;

  doubletlchar=#201;
  doubletrchar=#187;
  doubleblchar=#200;
  doublebrchar=#188;
  doublehlinechar=#205;
  doublevlinechar=#186;

type
  savedbytes=
    record
      buffer: array[1..maxsavedbytes] of char;
      count: integer;
      leftx: integer;
      topy: integer;
      rightx: integer;
      bottomy: integer;
    end;

procedure writexys(anx,any: integer; astr: string);

procedure singleline(leftx,topy,rightx,bottomy: integer);
procedure singlebox(leftx,topy,rightx,bottomy: integer);
procedure singleboxwh(leftx,topy,width,height: integer);

procedure doubleline(leftx,topy,rightx,bottomy: integer);
procedure doublebox(leftx,topy,rightx,bottomy: integer);
procedure doubleboxwh(leftx,topy,width,height: integer);

procedure emptybox(leftx,topy,rightx,bottomy: integer);
procedure emptyboxwh(leftx,topy,width,height: integer);

procedure savearea(leftx,topy,rightx,bottomy: integer;
 var saved: savedbytes);
procedure saveareawh(leftx,topy,width,height: integer;
 var saved: savedbytes);

{for restore, saved is var only for efficiency}
procedure restorearea(var saved: savedbytes);

procedure staticpopup(anx,any: integer; astr: string);
procedure removepopup;

implementation

var
  staticpopupsavedbytes: savedbytes;

procedure writexys;

begin
  gotoxy(anx,any);
  write(astr);
end;

procedure singleline;

var
  onex,oney: integer;

begin
  if leftx=rightx then
    for oney := topy to bottomy do
      writexys(leftx,oney,singlevlinechar)
  else
    for onex := leftx to rightx do
      writexys(onex,topy,singlehlinechar)
end;

procedure singlebox;

var
  x,y: integer;

begin
  singleline(leftx,topy,rightx,topy);
  singleline(leftx,bottomy,rightx,bottomy);

  singleline(leftx,topy,leftx,bottomy);
  singleline(rightx,topy,rightx,bottomy);

  writexys(leftx,topy,singletlchar);
  writexys(rightx,topy,singletrchar);
  writexys(leftx,bottomy,singleblchar);
  writexys(rightx,bottomy,singlebrchar);
end;

procedure singleboxwh;

begin
  singlebox(leftx,topy,leftx+width-1,topy+height-1);
end;

procedure doubleline;

var
  onex,oney: integer;

begin
  if leftx=rightx then
    for oney := topy to bottomy do
      writexys(leftx,oney,doublevlinechar)
  else
    for onex := leftx to rightx do
      writexys(onex,topy,doublehlinechar)
end;

procedure doublebox;

var
  x,y: integer;

begin
  doubleline(leftx,topy,rightx,topy);
  doubleline(leftx,bottomy,rightx,bottomy);

  doubleline(leftx,topy,leftx,bottomy);
  doubleline(rightx,topy,rightx,bottomy);

  writexys(leftx,topy,doubletlchar);
  writexys(rightx,topy,doubletrchar);
  writexys(leftx,bottomy,doubleblchar);
  writexys(rightx,bottomy,doublebrchar);
end;

procedure doubleboxwh;

begin
  doublebox(leftx,topy,leftx+width-1,topy+height-1);
end;
procedure emptybox;

var
  anx, any: integer;

begin
  for any := topy+1 to bottomy-1 do
    begin
      gotoxy(leftx+1,any);
      for anx := leftx+1 to rightx-1 do
        write(' ');
    end;
end;

procedure emptyboxwh;

begin
  emptybox(leftx,topy,leftx+width-1,topy+height-1);
end;

procedure savearea;

var
  anx,any: integer;
  regs: registers;

begin
  saved.leftx := leftx;
  saved.topy := topy;
  saved.rightx := rightx;
  saved.bottomy := bottomy;

  saved.count := 0;

  for anx := leftx to rightx do
    for any := topy to bottomy do
      if saved.count<maxsavedbytes-1 then
        begin
          gotoxy(anx,any);

{read character+attribute from screen}
          regs.ah := 8;
          regs.bh := 0;
          intr($10,regs);

{first character, then attribute}
          inc(saved.count);
          saved.buffer[saved.count] := chr(regs.al);
          inc(saved.count);
          saved.buffer[saved.count] := chr(regs.ah);
        end;
end;

procedure saveareawh;

begin
  savearea(leftx,topy,leftx+width-1,topy+height-1,saved);
end;

procedure restorearea;

var
  anx,any: integer;
  currbyte: integer;
  regs: registers;

begin
  currbyte := 0;

  for anx := saved.leftx to saved.rightx do
    for any := saved.topy to saved.bottomy do
      if currbyte<saved.count then
        begin
          gotoxy(anx,any);

{first character, then attribute}
          inc(currbyte);
          regs.al := ord(saved.buffer[currbyte]);
          inc(currbyte);
          regs.bl := ord(saved.buffer[currbyte]);

{write character+attribute to screen}
          regs.ah := 9;
          regs.bh := 0;
          regs.cx := 1;
          intr($10,regs);

        end;
end;

procedure staticpopup;

begin
  saveareawh(anx,any,length(astr)+2,3,staticpopupsavedbytes);
  singleboxwh(anx,any,length(astr)+2,3);
  writexys(anx+1,any+1,astr);
end;

procedure removepopup;

begin
  restorearea(staticpopupsavedbytes);
end;

end.